home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Monster Media 1994 #2
/
Monster Media No. 2 (Monster Media)(1994).ISO
/
prog_bas
/
tblevw.zip
/
TABLE.FRM
< prev
next >
Wrap
Text File
|
1994-05-18
|
11KB
|
405 lines
VERSION 2.00
Begin Form TableForm
BackColor = &H00808080&
Caption = "View Table Sample"
ClientHeight = 3150
ClientLeft = 1740
ClientTop = 2100
ClientWidth = 6090
Height = 3840
Icon = TABLE.FRX:0000
Left = 1680
LinkTopic = "Form1"
ScaleHeight = 3150
ScaleWidth = 6090
Top = 1470
Width = 6210
Begin TrueGrid Table1
AllowArrows = -1 'True
AllowTabs = -1 'True
BackColor = &H00C0C0C0&
Editable = -1 'True
EditDropDown = -1 'True
ExposeCellMode = 0 'Expose upon selection
FetchMode = 0 'By cell
FontBold = 0 'False
FontItalic = 0 'False
FontName = "MS Sans Serif"
FontSize = 8.25
FontStrikethru = 0 'False
FontUnderline = 0 'False
HeadingHeight = 1
Height = 1815
HorzLines = 0 'None
Layout = TABLE.FRX:0302
LayoutIndex = 1
Left = 120
LinesPerRow = 1
MarqueeUnique = -1 'True
SplitPropsGlobal= -1 'True
SplitTabMode = 0 'Don't tab across splits
TabCapture = 0 'False
TabIndex = 0
Top = 120
UseBookmarks = -1 'True
Width = 2775
WrapCellPointer = 0 'False
End
Begin Menu ExitMenuOption
Caption = "E&xit!"
End
Begin Menu IndexMenuOption
Caption = "&Indexes"
Visible = 0 'False
Begin Menu IndexMenu
Index = 0
End
End
Begin Menu HelpMenuOption
Caption = "&Help"
Begin Menu HelpMenu
Caption = "&Index"
Index = 0
End
Begin Menu HelpMenu
Caption = "&Using Help"
Index = 1
End
Begin Menu HelpMenu
Caption = "-"
Index = 2
End
Begin Menu HelpMenu
Caption = "&About View Table..."
Index = 3
End
End
End
Sub CenterForm (F As Form)
' Center the specified form within the screen
F.Move (Screen.Width - F.Width) \ 2, (Screen.Height - F.Height) \ 2
End Sub
Sub CheckForIndexes ()
' If Indexes exist then show Index menu option
If Tb.Indexes.Count > 0 Then
IndexMenuOption.Visible = True
IndexMenu(0).Visible = True
IndexMenu(0).Checked = True
IndexMenu(0).Caption = "&None"
' Add Index menu option for each index
For ct = 0 To Tb.Indexes.Count - 1
Load IndexMenu(ct + 1)
IndexMenu(ct + 1).Caption = Tb.Indexes(ct)
IndexMenu(ct + 1).Checked = False
Next ct
End If
End Sub
Sub ExitApp ()
' Close database and table before exiting
Tb.Close
Db.Close
End
End Sub
Sub ExitMenuOption_Click ()
Unload Me
End Sub
Sub FieldLayout ()
' Get Field Layout to determine field display
' and data entry size
For ct = 0 To Tb.Fields.Count - 1
'Set display heading to database fieldname
FldName = Tb.Fields(ct).Name
Table1.ColumnName(ct + 1) = FldName
'Get width of fieldname
NameWidth = Len(FldName)
'Get type of field to determine it's display size
Select Case Tb.Fields(ct).Type
Case 1, 10 'Text and Logic types
FldSize = Tb.Fields(ct).Size
Case 3 'Integer type
FldSize = 7
Case 4, 8 'Long and date types
FldSize = 14
Case 5, 6, 7 'Currency, Single, Double types
FldSize = 10
Case 11, 12 'Memo and binary types
FldSize = 25
End Select
' Use field width or the field name width whichever is larger
If NameWidth > FldSize Then
Table1.ColumnWidth(ct + 1) = NameWidth + 2
Else
Table1.ColumnWidth(ct + 1) = FldSize + 2
End If
' Set data entry width to Field size
Table1.ColumnSize(ct + 1) = FldSize
Next ct
End Sub
Sub Form_Load ()
'Center the sample on the screen
CenterForm TableForm
' Open Database and Table functions
OpenDb ("market.mdb")
OpenTb ("Contact_Info")
' Estimate begining size, put approx size in MAXROW
EndRow = MAXROW
' Set grid Rows to estimated MAXROW
Table1.Rows = MAXROW
' Set Current Row to one
Temp = MoveToRow(1)
' Function to add indexes to the menu if any exist
CheckForIndexes
' Function to setup grids columns
FieldLayout
End Sub
Sub Form_Resize ()
'Make the grid to the size of the form
Table1.Move 0, 0, ScaleWidth, ScaleHeight
End Sub
Sub Form_Unload (Cancel As Integer)
ExitApp
End Sub
Sub HelpMenu_Click (Index As Integer)
'This event calls the WinHelp EXE and a location to goto based on which selection the user has chosen
'Case 4 shows the about box for the Callback sample
Select Case Index
Case 0
HelpContext TableForm, HELP_VIEWTABLE
Case 1
HelpOnHelp TableForm
Case 3
About.Show 1
End Select
End Sub
Sub IndexMenu_Click (Index As Integer)
If IndexMenu(Index).Checked <> True Then
' Set Index to whichever one the user chooses
Select Case Index
Case 0
SetIndex ("")
Case Else
SetIndex (IndexMenu(Index).Caption)
End Select
' Refresh grid, move to beginning, reset table row
Table1.Refresh
Table1.RowIndex = 1
Temp = MoveToRow(1)
' Turn off all check marks
For ct = 0 To Tb.Indexes.Count
IndexMenu(ct).Checked = False
Next ct
' Check value user choose
IndexMenu(Index).Checked = True
End If
End Sub
Function MoveToRow (NewRow As Long) As Long
Dim CurDiff, EndDiff, BeginDiff As Long
' Find differences between beginning, end and current position
CurDiff = Abs(CurrentRow - NewRow)
EndDiff = EndRow - NewRow
BeginDiff = NewRow - 1
' If values are same no need to move db
If CurrentRow = NewRow Then
MoveToRow = CurrentRow
Exit Function
' If moving forward in db
ElseIf CurrentRow < NewRow Then
' Check to see if End is closer, if not
' move from current position to new position
If EndDiff > CurDiff Then
For ct = 1 To CurDiff
Tb.MoveNext
If Tb.EOF Then
CurrentRow = Tb.RecordCount
MoveToRow = CurrentRow
Exit Function
Else
CurrentRow = CurrentRow + 1
End If
Next ct
' If end is closer move to the end of the database
' and go backwards to the new position
Else
Tb.MoveLast
CurrentRow = Tb.RecordCount
'Check to see if estimated equal actual, if not equal
'exit function so CheckRows can set the actual EndRow value
If EndRow = Tb.RecordCount Then
For ct = 1 To EndDiff
Tb.MovePrevious
CurrentRow = CurrentRow - 1
Next ct
End If
End If
' Moving backward in db
Else
' If BeginDiff is greater than CurDiff then move
' from current position to new position
If BeginDiff > CurDiff Then
For ct = 1 To CurDiff
Tb.MovePrevious
If Tb.BOF Then
CurrentRow = 1
MoveToRow = CurrentRow
Exit Function
Else
CurrentRow = CurrentRow - 1
End If
Next ct
' If beginning is closer then move from
' beginning to new position
Else
Tb.MoveFirst
CurrentRow = 1
For ct = 1 To BeginDiff
Tb.MoveNext
CurrentRow = CurrentRow + 1
Next ct
End If
End If
MoveToRow = CurrentRow
End Function
Sub OpenDb (DbName As String)
' Put your open database code here
ChDir App.Path
Set Db = OpenDatabase(DbName)
End Sub
Sub OpenTb (TableName As String)
' Put your open table code here
Set Tb = Db.OpenTable(TableName)
End Sub
Sub SetIndex (IndexVal As String)
' If you database type supports multiple indexes
' set the index type you want to use here
Tb.Index = IndexVal
End Sub
Sub Table1_CheckRows (RequestRows As Long, CurRows As Long)
' Move in table to value specified by RequestRows
NewRow = MoveToRow(RequestRows)
' If table did not make it to the NewRow value
' i.e. NewRow was not attainable then
' end of db was reached
If NewRow <> RequestRows Then
' Set CurRows to actual end of file
CurRows = NewRow
' Set EndRow to actual end of file
EndRow = NewRow
End If
End Sub
Sub Table1_Fetch (row As Long, Col As Integer, Value As String)
' This condition should always be true because of the
' code in the CheckRows events but we double check
NewRow = MoveToRow(row)
' Debug.Print "OR=" & Str$(row)
' Debug.Print "NR =" & Str$(NewRow)
If NewRow = row Then
' If field is empty trap Null and use empty quotes instead
If IsNull(Tb(Col - 1)) Then
Value = ""
Else
Value = Tb(Col - 1)
End If
Else
MsgBox "Error in navigating database"
End If
End Sub
Sub Table1_Update (row As Long, Col As Integer, Value As String)
' This should always be true because of the code in the
' CheckRows but we double check anyways
If MoveToRow(row) = row Then
Call UpdateTable(Col, Value)
Else
MsgBox "Error updating value"
End If
End Sub
Sub UpdateTable (Column As Integer, NewValue As String)
' There is no error checking so becareful
' of data mismatches!!!
Tb.Edit
Tb(Column - 1) = NewValue
Tb.Update
End Sub